home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue39 / Clinic / AdItm3U2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-07-16  |  7.3 KB  |  214 lines
  1. unit AdItm3U2;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils;
  7.  
  8. type
  9.   EShellError = class(Exception);
  10.  
  11. procedure CreateShortCut(const Folder, Description, Path, Arguments,
  12.   Directory, IconPath: String; IconIndex: Integer; ShowMin: Boolean);
  13.  
  14. implementation
  15.  
  16. {$ifdef Ver80} { Delphi 1.0x }
  17.   {$define DelphiLessThan3}
  18. {$endif}
  19. {$ifdef Ver90} { Delphi 2.0x }
  20.   {$define DelphiLessThan3}
  21. {$endif}
  22. {$ifdef Ver93} { C++ Builder 1.0x }
  23.   {$define DelphiLessThan3}
  24. {$endif}
  25.  
  26. uses
  27. {$ifdef Win32}
  28.   {$ifdef DelphiLessThan3}
  29.   Ole2,
  30.   {$else}
  31.   ShlObj, ActiveX, ComObj,
  32.   {$endif}
  33. {$endif}
  34.   WinTypes, WinProcs, Forms, Dialogs, ShellAPI, DdeMan;
  35.  
  36. {$ifdef Win32}
  37.   {$ifdef DelphiLessThan3}
  38. type
  39.   TSHItemID = packed record           { mkid }
  40.     cb: Word;                         { Size of the ID (including cb itself) }
  41.     abID: array[0..0] of Byte;        { The item ID (variable length) }
  42.   end;
  43.  
  44.   PItemIDList = ^TItemIDList;
  45.   TItemIDList = packed record
  46.     mkid: TSHItemID;
  47.   end;
  48.  
  49.   IShellLink = class(IUnknown)
  50.   public
  51.     function GetPath(pszFile: PChar; cchMaxPath: Integer; var pfd: TWin32FindData; fFlags: Integer): HResult;
  52.       virtual; stdcall; abstract;
  53.     function GetIDList(var ppidl: PItemIDList): HResult; virtual; stdcall; abstract;
  54.     function SetIDList(var ppidl: PItemIDList): HResult; virtual; stdcall; abstract;
  55.     function GetDescription(pszName: PChar; cchMaxName: Integer): HResult; virtual; stdcall; abstract;
  56.     function SetDescription(pszName: PChar): HResult; virtual; stdcall; abstract;
  57.     function GetWorkingDirectory(pszDir: PChar; cchMaxPath: Integer): HResult; virtual; stdcall; abstract;
  58.     function SetWorkingDirectory(pszDir: PChar): HResult; virtual; stdcall; abstract;
  59.     function GetArguments(pszArgs: PChar; cchMaxPath: Integer): HResult; virtual; stdcall; abstract;
  60.     function SetArguments(pszArgs: PChar): HResult; virtual; stdcall; abstract;
  61.     function GetHotkey(var pwHotKey: Word): HResult; virtual; stdcall; abstract;
  62.     function SetHotkey(pwHotKey: Word): HResult; virtual; stdcall; abstract;
  63.     function GetShowCmd(var piShowCmd: Integer): HResult; virtual; stdcall; abstract;
  64.     function SetShowCmd(piShowCmd: Integer): HResult; virtual; stdcall; abstract;
  65.     function GetIconLocation(pszIconPath: PChar; cchIconPath: Integer; var piIcon: Integer): HResult;
  66.       virtual; stdcall; abstract;
  67.     function SetIconLocation(pszIconPath: PChar; piIcon: Integer): HResult; virtual; stdcall; abstract;
  68.     function SetRelativePath(pszPathRel: PChar; dsReserved: Integer): HResult; virtual; stdcall; abstract;
  69.     function Resolve(fFlags: Integer): HResult; virtual; stdcall; abstract;
  70.     function SetPath(pszFile: PChar): HResult; virtual; stdcall; abstract;
  71.   end;
  72.  
  73. const
  74.   CLSID_ShellLink: TGUID = (
  75.     D1:$00021401; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  76.   IID_ShellLink: TGUID = (
  77.     D1:$000214EE; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  78.  
  79.   CSIDL_PROGRAMS = 2;
  80.   {$endif}
  81.  
  82. var
  83.   ShellHdl: THandle;
  84.   SHGetSpecialFolderLocation: function(hwndOwner: HWND; nFolder: Integer; var ppidl: PItemIDList): HResult; stdcall;
  85.   SHGetPathFromIDList: function(pidl: PItemIDList; pszPath: PChar): BOOL; stdcall;
  86.   SHGetMalloc: function(var ppMalloc: IMalloc): HResult; stdcall;
  87.  
  88. function Succeeded(Res: HResult): Boolean;
  89. begin
  90.   Result := Res and $80000000 = 0;
  91. end;
  92.  
  93. procedure OleCheck(Result: HResult);
  94. var
  95.   S: string;
  96. begin
  97.   if not Succeeded(Result) then
  98.   begin
  99.     S := SysErrorMessage(Result);
  100.     if S = '' then
  101.       FmtStr(S, 'OLE error %.8x', [Result]);
  102.     raise EShellError(S)
  103.   end
  104. end;
  105.  
  106. function GetLocation(Folder: DWord): String;
  107. var
  108.   PIDList: PItemIDList;
  109.   Buf: array[0..MAX_PATH] of Char;
  110.   Malloc: IMalloc;
  111. begin
  112.   if SHGetSpecialFolderLocation(Application.Handle, Folder, PIDList) <> NOERROR then
  113.     raise EShellError.Create('Cannot find desktop folder');
  114.   if SHGetPathFromIDList(PIDList, Buf) then
  115.     Result := StrPas(Buf);
  116.   if (SHGetMalloc(Malloc) = NOERROR) then
  117.     Malloc.Free(PIDList)
  118. end;
  119. {$endif}
  120.  
  121. procedure CreateShortCut(const Folder, Description, Path, Arguments,
  122.   Directory, IconPath: String; IconIndex: Integer; ShowMin: Boolean);
  123. var
  124.   Cmd: array[0..255] of Char;
  125. {$ifdef Win32}
  126. var
  127.   ShellLink: IShellLink;
  128.   PersistFile: IPersistFile;
  129.   LinkFile: array [0..MAX_PATH] of WideChar;
  130.   FolderPath, ShortCutPath: String;
  131. const
  132.   ShowCmd: array[Boolean] of Integer = (sw_ShowNormal, sw_Minimize);
  133. {$endif}
  134. begin
  135. {$ifdef Win32}
  136.   if ShellHdl <> 0 then
  137.   begin
  138.     FolderPath := GetLocation(CSIDL_PROGRAMS) + '\' + Folder;
  139.     { Unlike MkDir, this doesn't raise an exception if it fails }
  140.     CreateDirectory(PChar(FolderPath), nil);
  141.     { To display the folder when creating shortcuts, uncomment this line }
  142.     { ShellExecute(Application.Handle, nil, PChar(FolderPath), nil, nil, sw_ShowNormal); }
  143.     {$ifdef DelphiLessThan3}
  144.     if CoInitialize(nil) > 0 then
  145.     begin
  146.       try
  147.         OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_ShellLink, ShellLink));
  148.         OleCheck(ShellLink.QueryInterface(IID_IPersistFile, PersistFile));
  149.     {$else}
  150.         ShellLink := CreateComObject(CLSID_ShellLink) as IShellLink;
  151.         PersistFile := ShellLink as IPersistFile;
  152.     {$endif}
  153.         ShellLink.SetDescription(PChar(Description));
  154.         ShellLink.SetPath(PChar(Path));
  155.         ShellLink.SetArguments(PChar(Arguments));
  156.         ShellLink.SetWorkingDirectory(PChar(Directory));
  157.         ShellLink.SetIconLocation(PChar(IconPath), IconIndex);
  158.         ShellLink.SetShowCmd(ShowCmd[ShowMin]);
  159.  
  160.         ShortCutPath := FolderPath + '\' + Description;
  161.         if UpperCase(ExtractFileExt(ShortcutPath)) <> '.LNK' then
  162.           ShortCutPath := ShortCutPath + '.LNK';
  163.         { In Delphi 3, we could rewrite the following two statements as: }
  164.         { OleCheck(PWideChar(WideString(ShortCutPath)), True); }
  165.         StringToWideChar(ShortCutPath, LinkFile, SizeOf(LinkFile));
  166.         OleCheck(PersistFile.Save(LinkFile, True));
  167.     {$ifdef DelphiLessThan3}
  168.         PersistFile.Release;
  169.         ShellLink.Release;
  170.       finally
  171.         CoUninitialize;
  172.       end
  173.     end
  174.     {$endif}
  175.   end
  176.   else
  177. {$endif}
  178.     with TDdeClientConv.Create(nil) do
  179.       try
  180.         SetLink('ProgMan', '');
  181.         OpenLink;
  182.         try
  183.           StrPCopy(Cmd, Format('[CreateGroup(%s)]'#13#10, [Folder]));
  184.           ExecuteMacro(Cmd, False);
  185.           { AddItem(CmdLine, Description, IconFile, IconIndex, X, Y, DefDir, Hotkey, Minimize }
  186.           StrPCopy(Cmd, Format('[AddItem(%s %s, %s, %s, %d, , , %s, , 0)]'#13#10,
  187.             [Path, Arguments, Description, IconPath, IconIndex, Directory]));
  188.           if not ExecuteMacro(Cmd, False) then
  189.             raise EShellError.Create('Unable to create item.')
  190.         finally
  191.           CloseLink
  192.         end
  193.       finally
  194.         Free
  195.       end;
  196. end;
  197.  
  198. initialization
  199. {$ifdef Win32}
  200.   ShellHdl := LoadLibrary('Shell32.Dll');
  201.   if ShellHdl > HInstance_Error then
  202.   begin
  203.     SHGetSpecialFolderLocation := GetProcAddress(ShellHdl, 'SHGetSpecialFolderLocation');
  204.     SHGetPathFromIDList := GetProcAddress(ShellHdl, 'SHGetPathFromIDList');
  205.     SHGetMalloc := GetProcAddress(ShellHdl, 'SHGetMalloc');
  206.   end
  207.   else
  208.     ShellHdl := 0
  209. finalization
  210.   if ShellHdl <> 0 then
  211.     FreeLibrary(ShellHdl)
  212. {$endif}
  213. end.
  214.